import Control.Monad
import Data.Fits.RecordParser
import Data.Fits.KeywordRecord
import Text.ParserCombinators.Parsec

serializeHDU :: HDU -> Maybe B.ByteString
serializeHDU hdu = do
  h <- sequence $ header hdu
  h1 = concat h  


class Dimension a where
  dimension :: a -> Int
  axis :: a -> [Int]

instance Dimension Int where
  dimension _ = 1
  axis x = [x]

instance Dimension (Int,Int) where
  dimension _ = 2
  axis (a,b) = [a,b]

instance Dimension (Int,Int,Int) where
  dimension _ = 3
  axis (a,b,c) = [a,b,c]

fromIArray :: (IArray a e, Ix i) => a i e -> HDU
fromIArray array = HDU {header = h, unit = raw} where
  (a,b)   = bounds array
  naxis   = dimension a
  naxises = zipWith (-) (axis b) (axis a)
  
  h = [ ValueRecord "SIMPLE" (toValue True) "file conforms to FITS standard"
      , ValueRecord "BITPIX" ??? "number of bits per data pixel" 
      , ValueRecord "NAXIS" (toValue naxis) "number of data axes"
      , ValueRecord 
      , ValueRecord]      
  
          let head = [ Record (Keyword "SIMPLE") (VBool True)  "file conforms to FITS standard"
                     , Record (Keyword "BITPIX") (VInt 16)     "number of bits per data pixel"
                     , Record (Keyword "NAXIS")  (VInt 2)      "number of data axes"
                     , Record (Keyword "NAXIS1") (VInt w)      "length of data axis 1"
                     , Record (Keyword "NAXIS2") (VInt h)      "length of data axis 2"
                     , Record (Keyword "BZERO")  (VInt (2^15)) "physical value = BZERO + array value"
                     , END
                     ]

    

capture :: Int -> String -> (String, String)
capture _ [] = ("", "")
capture 0 x = ("", x)
capture n (x:xs) = let (a,b) = capture (n-1) xs
                   in (x:a,b)

splitBy :: Int -> String -> [String]
splitBy n x = let (a,b) = capture n x
              in case b of
                [] -> [a]
                _  -> a : splitBy n b


serializeKeywordValue :: (FitsValue a) => String -> a -> String -> Bool -> Maybe [String]
serializeKeywordValue key a comment fixed = do
  let value = toValue a
  k <- serializeKey key
  v <- serializeValue value fixed
  let part1 = k ++ "= " ++ v
  let len = length part1
  guard (len <= 80)
  let cs | len >= 78 = "" : splitBy 40 comment
  let cs | otherwise = let (a,b) = capture (78-len) comment
                       in if null b then [a]
                                    else a : splitBy 40 b
  let vs = case cs of
            [] -> []


createKeywordValue :: (FitsValue a) => String -> a -> String -> Bool -> Maybe [KeywordRecord]
createKeywordValue key a comment fixed = do
  let value = toValue a
  k <- serializeKey key
  v <- serializeValue value fixed
  let part1 = k ++ "= " ++ v
  let len = length part1
  guard (len <= 80)
  let cs | len >= 78 = "" : splitBy 40 comment
  let cs | otherwise = let (a,b) = capture (78-len) comment
                       in if null b then [a]
                                    else a : splitBy 40 b
  let vs = case cs of
             []     -> [ValueRecord key value ""]
             (c:cs) -> (ValueRecord key value c) : map (CommentaryRecord . BLANKFIELDKeyword) cs
  return vs

serializeKey :: String -> Maybe String
serializeKey s = do
  guard (length s <= 8)
  let r = alignLeft 8 s ' '
  case (parse keywordParser "" r) of
    Left  _ -> Nothing
    Right _ -> return r 

serialize' v True  | length s > 20 = Nothing
                   | otherwise = Just $ alignRight 20 s ' ' where s = show v
serialize' v False | length s > 20 = Just s
                   | otherwise = serialize' v True where s = show v

serializeValue :: Value -> Bool -> Maybe String
serializeValue v@(CharacterStringValue _) _ = Just $ "'" ++ show v ++ "'"
serializeValue v@(LogicalValue _) _ = serialize' v True
serializeValue v@(IntegerValue _) f = serialize' v f
serializeValue v@(FloatingValue _) f = serialize' v f
serializeValue v@(ComplexIntegerValue _) _ = serialize' v False
serializeValue v@(ComplexFloatValue _) _ = serialize' v False
serializeValue Undefined _ = Just $ alignRight 20 "" ' '       

alignLeft n s c | len > n = error "Ne mogu virovnit stroku"
                | len == n = s
                | len < n = s ++ r where
  len = length s
  r = take (n - len) $ repeat c

alignRight n s c | len > n = error "Ne mogu virovnit stroku"
                 | len == n = s
                 | len < n = r ++ s where
  len = length s
  r = take (n - len) $ repeat c

